Shareware Grab Bag/Shareware Grab Bag.iso/050/pasfile.lqr/FILES.PAS

Pascal/Delphi Source File | 1985-06-03 | 20KB | 753 lines

{
  A flexible directory lister
  written October, 1984
  by Preston L. Bannister

  For each file found a line is written in the format specified by a macro
  string.
}

{$c+}

program main;

{ i msdos.p }
{ ..... 8086 registers and flags -- for INTR() and MSDOS() calls ..... }

const
  carry_flag     = 1;
  parity_flag    = 4;
  aux_carry_flag = 16;
  zero_flag      = 64;
  sign_flag      = 128;

type
  registers =
    record case integer of
      1:(ax,bx,cx,dx,bp,si,di,ds,es,flags : integer);
      2:(al,ah,bl,bh,cl,ch,dl,dh : byte)
    end;

{ ..... Standard MSDOS files, file attributes, and error codes ..... }

const
  invalid_file = -1;

  stdin  = 0;   { standard input file handle }
  stdout = 1;   { standard output file handle }
  stderr = 2;   { standard error file handle }

  attribute_read_only = 1;
  attribute_hidden    = 2;
  attribute_system    = 4;
  attribute_volume_id = 8;
  attribute_directory = 16;
  attribute_archive   = 32;

  no_error                  = 0;
  error_invalid_function    = 1;
  error_file_not_found      = 2;
  error_path_not_found      = 3;
  error_too_many_open_files = 4;
  error_access_denied       = 5;
  error_invalid_handle      = 6;
  error_arena_trashed       = 7;
  error_not_enough_memory   = 8;
  error_invalid_block       = 9;
  error_bad_environment     = 10;
  error_bad_format          = 11;
  error_invalid_access      = 12;
  error_invalid_data        = 13;
  error_invalid_drive       = 15;
  error_current_directory   = 16;
  error_not_same_device     = 17;
  error_no_more_files       = 18;
{ i msdosio.p }
{ ..... Standard MSDOS file access routines ..... }


{ Create a file }

function createf (var fh : integer; var name; attribute : integer) : integer;
  var reg : registers;
  begin
    reg.ah := $3C;
    reg.ds := seg(name);
    reg.dx := ofs(name);
    reg.cx := attribute;
    msdos(reg);
    if (carry_flag and reg.flags) = 0 then
      begin fh := reg.ax; createf := 0; end
    else
      begin fh := -1; createf := reg.ax; end;
  end;


{  Delete a file }

function deletef (var name) : integer;
  var reg : registers;
  begin
    reg.ah := $41;
    reg.ds := seg(name);
    reg.dx := ofs(name);
    msdos(reg);
    if (carry_flag and reg.flags) = 0 then
      deletef := 0
    else
      deletef := reg.ax;
  end;


{ Open a file }

type file_access = (read_only, write_only, read_write);

function openf (var fh : integer; var name; access : file_access) : integer;
  var reg : registers;
  begin
    reg.ah := $3D;
    reg.ds := seg(name);
    reg.dx := ofs(name);
    reg.al := ord(access);
    msdos(reg);
    if (carry_flag and reg.flags) = 0 then
      begin openf := 0; fh := reg.ax; end
    else
      begin openf := reg.ax; fh := -1; end;
  end;


{ Close a file handle }

procedure closef (fh : integer);
  var reg : registers;
  begin
    reg.ah := $3E;
    reg.bx := fh;
    msdos(reg);
  end;


{ Read from a file }

function readf (fh : integer; var buffer; var bytes : integer) : integer;
  var reg : registers;
  begin
    reg.ah := $3F;
    reg.ds := seg(buffer);
    reg.dx := ofs(buffer);
    reg.cx := bytes;
    reg.bx := fh;
    msdos(reg);
    if (carry_flag and reg.flags) = 0 then
      begin readf := 0; bytes := reg.ax; end
    else
      begin readf := reg.ax; bytes := 0; end;
  end;


{ Write to a file }

function writef (fh : integer; var buffer; var bytes : integer) : integer;
  var reg : registers;
  begin
    reg.ah := $40;
    reg.ds := seg(buffer);
    reg.dx := ofs(buffer);
    reg.cx := bytes;
    reg.bx := fh;
    msdos(reg);
    if (carry_flag and reg.flags) = 0 then
      begin writef := 0; bytes := reg.ax; end
    else
      begin writef := reg.ax; bytes := 0; end;
  end;
{ i lookup.p }
{
  Access to the file system - get/set current drive/path and file lookup
  written October, 1984
  by Preston L. Bannister
  -- depends on MSDOS.P
}


{ Get the text of the current directory path on the given drive
  - assumes at least 64 bytes availible for path name
}


function get_path (drive : integer; var path_name) : integer;
  var reg : registers;
  begin
    reg.ah := $47;
    reg.ds := seg(path_name);
    reg.si := ofs(path_name);
    reg.dl := drive;
    msdos(reg);
    if (carry_flag and reg.flags) = 0 then
      get_path := no_error
    else
      get_path := reg.ax;
  end;


{ Change the current directory }

function set_path (var path_name) : integer;
  var reg : registers;
  begin
    reg.ah := $3B;
    reg.ds := seg(path_name);
    reg.dx := ofs(path_name);
    msdos(reg);
    if (carry_flag and reg.flags) = 0 then
      set_path := no_error
    else
      set_path := reg.ax;
  end;


{ Set disk transfer address }

procedure set_dma (var buffer);
  var reg : registers;
  begin
    reg.ah := $1A;
    reg.ds := seg(buffer);
    reg.dx := ofs(buffer);
    msdos(reg);
  end;


{ Set the default drive }

procedure set_default_drive (drive : integer);
  var reg : registers;
  begin
    reg.ah := $0E;
    reg.dl := drive;
    msdos(reg);
  end;


{ Get the default drive }

function get_default_drive : integer;
  var reg : registers;
  begin
    reg.ah := $19;
    msdos(reg);
    get_default_drive := reg.al;
  end;


{ Get the number of logical drives }

function number_of_drives : integer;
  var reg : registers;
  begin
    reg.ah := $19;
    msdos(reg);
    reg.ah := $0E;
    reg.dl := reg.al;
    msdos(reg);
    number_of_drives := reg.al;
  end;


{ the buffer used by the find first/next routines }

type file_info =
  record
    attr : byte;
    time : integer;
    date : integer;
    size_l : integer;
    size_h : integer;
    pname : array [1..13] of char;
  end;

type find_buf =
  record
   { CAVEAT PROGRAMMER ---> }
    sattr       : byte;
    drive       : byte;
    name        : array [1..11] of char;
    last_ent    : integer;
    this_dpb    : ^ integer;
    dir_start   : integer;
   { <--- CAVEAT PROGRAMMER }
    info        : file_info;
  end;


{ Find the first file to match the given spec }

function find_first (var buf : find_buf; var name; attr : integer) : integer;
  var reg : registers;
  begin
    set_dma(buf);
    reg.ah := $4E;
    reg.ds := seg(name);
    reg.dx := ofs(name);
    reg.cx := attr;
    msdos(reg);
    if (carry_flag and reg.flags) = 0 then
      find_first := no_error
    else
      find_first := reg.ax;
  end;


{ Find the next file to match the previously given spec }

function find_next (var buf : find_buf) : integer;
  var reg : registers;
  begin
    set_dma(buf);
    reg.ah := $4F;
    msdos(reg);
    if (carry_flag and reg.flags) = 0 then
      find_next := no_error
    else
      find_next := reg.ax;
  end;


{ Lookup the file with the given (path) name, return file info }

function lookup (var name; attr : integer; var info : file_info) : integer;
  var buf : find_buf; error : integer;
  begin
    lookup := find_first(buf,name,attr);
    info := buf.info;
  end;
{ i chars.p }

type char_array = array [0..0] of char;

function scan_until (var s; ch : char; max : integer) : integer;
  var i : integer; c : char_array absolute s;
  begin
    i := 0;
    while (c[i] <> ch) and (i < max) do i := succ(i);
    scan_until := i;
  end;

function scan_back_until (var s; ch : char; max : integer) : integer;
  var i : integer; c : char_array absolute s;
  begin
    i := 0;
    while (c[-i] <> ch) and (i < max) do i := succ(i);
    scan_back_until := i;
  end;

function scan_while (var s; ch : char; max : integer) : integer;
  var i : integer; c : char_array absolute s;
  begin
    i := 0;
    while (c[i] = ch) and (i < max) do i := succ(i);
    scan_while := i;
  end;

function pop_token (var src, dst; max : integer; var n : integer) : integer;
  var i, j : integer; s : char_array absolute src;
  begin
    i := scan_while(s[0],' ',max);
    j := i + scan_until(s[i],' ',(max - i));
    n := (j - i);
    move(s[i],dst,n);
    pop_token := j;
  end;

procedure upcase_chars (var s; n : integer);
  var i : integer; ch : char_array absolute s;
  begin
    for i := 0 to n - 1 do ch[i] := upcase(ch[i]);
  end;

const digit : array [0..15] of char = '0123456789ABCDEF';

function hex_to_chars (h, n : integer; var s) : integer;
  var c : char_array absolute s;
  begin hex_to_chars := n;
    while (n > 0) do
      begin n := pred(n); c[n] := digit[h and $000F]; h := h shr 4; end;
  end;

function dec_to_chars (d, n : integer; var s; zeros : boolean) : integer;
  var c : char_array absolute s;
  begin dec_to_chars := n;
    repeat
      n := pred(n); c[n] := digit[d mod 10]; d := d div 10;
    until (n <= 0) or ((not zeros) and (d = 0));
    while (n > 0) do begin n := pred(n); c[n] := ' '; end;
  end;

function asciiz_to_chars (var a; n : integer; var s) : integer;
  var c : char_array absolute a; m : integer; d : char_array absolute s;
  begin asciiz_to_chars := n;
    m := scan_until(c[0],#0,n);
    move(c,d,m);
    fillchar(d[m],n - m,' ');
  end;
{ i vols.p }

{ structures used by fcb_ calls }

type fcb_name = array [1..11] of char;

type _fcb =
  record
    flag : byte;
    _6_2 : array [-6..-2] of byte;
    attr : byte;
    drive : byte;
    name : fcb_name;
    _12_16 : array [12..16] of byte;
    new_name : fcb_name;
  end;

type opened_fcb =
  record
    flag : byte;
    _6_2 : array [-6..-2] of byte;
    attr : byte;
    drive : byte;
    name : fcb_name;
    rest : array [12..36] of integer;
  end;

const any_name : fcb_name = '???????????';


{ Find the first file matching the name }

function fcb_find_first (
                     drive, attr : byte;
                     name : fcb_name;
                     var out_fcb : opened_fcb
                    ) : boolean;
  var reg : registers; fcb : _fcb;
  begin
    set_dma(out_fcb);
    fcb.flag  := $FF;
    fcb.drive := drive;
    fcb.attr  := attr;
    fcb.name  := name;
    reg.ah := $11;
    reg.ds := seg(fcb);
    reg.dx := ofs(fcb);
    msdos(reg);
    fcb_find_first := (reg.al = 0);
  end;


{ Rename the file refered to by the FCB }

function fcb_rename (drive, attr : byte; name, new_name : fcb_name) : boolean;
  var reg : registers; fcb : _fcb;
  begin
    fcb.flag  := $FF;
    fcb.drive := drive;
    fcb.attr  := attr;
    fcb.name  := name;
    fcb.new_name := new_name;
    reg.ah := $17;
    reg.ds := seg(fcb);
    reg.dx := ofs(fcb);
    msdos(reg);
    fcb_rename := (reg.al = 0);
  end;


{ Disk Reset - make sure next action checks disk first }

procedure disk_reset;
  var reg : registers;
  begin reg.ah := $0D; msdos(reg) end;


{ Get the volume id (label) for the disk in the given drive }

function get_volume_id (drive : byte; var name : fcb_name) : boolean;
  var fcb : opened_fcb;
  begin
    get_volume_id := fcb_find_first(drive,attribute_volume_id,any_name,fcb);
    name := fcb.name;
  end;


{ Set the volume id (label) for the disk in the given drive }

function set_volume_id (drive : byte; new_name : fcb_name) : boolean;
  var new_namez : string[16]; fh : integer;
  begin
    set_volume_id := true;
    disk_reset;
    if not fcb_rename(drive,attribute_volume_id,any_name,new_name) then
      begin
        new_namez := new_name + #0;
        insert('.',new_namez,9);
        if drive <> 0 then
          begin
            insert('@:',new_namez,1);
            new_namez[1] := chr(ord('@') + drive);
          end;
        if createf(fh,new_namez[1],attribute_volume_id) = no_error then
          closef(fh)
        else
          set_volume_id := false;
      end;
  end;

{ end of includes }


function time_to_chars (t : integer; var s) : integer;
  var c : char_array absolute s; i : integer;
  begin time_to_chars := 8;
    i := dec_to_chars((t shr 11),2,c[0],true);
    c[2] := ':';
    i := dec_to_chars((t and $07E0) shr 5,2,c[3],true);
    c[5] := ':';
    i := dec_to_chars((t and $001F),2,c[6],true);
  end;

function date_to_chars (d : integer; var s) : integer;
  var c : char_array absolute s; i : integer;
  begin date_to_chars := 8;
    i := dec_to_chars(80 + (d shr 9),2,c[0],true);
    c[2] := '-';
    i := dec_to_chars((d and $01E0) shr 5,2,c[3],true);
    c[5] := '-';
    i := dec_to_chars((d and $001F),2,c[6],true);
  end;

function attr_to_chars (a : integer; var s) : integer;
  var c : char_array absolute s; i : integer;
  begin attr_to_chars := 6;
    fillchar(c[0],6,'-');
    if (attribute_read_only and a) <> 0 then c[5] := 'r';
    if (attribute_hidden    and a) <> 0 then c[4] := 'h';
    if (attribute_system    and a) <> 0 then c[3] := 's';
    if (attribute_volume_id and a) <> 0 then c[2] := 'v';
    if (attribute_directory and a) <> 0 then c[1] := 'd';
    if (attribute_archive   and a) <> 0 then c[0] := 'a';
  end;

function kbytes_to_chars (var f : find_buf; var s) : integer;
  var c : char_array absolute s; i, k : integer;
  begin kbytes_to_chars := 5;
    k := (f.info.size_l + 1023) shr 10 + (f.info.size_h shl 6);
    i := dec_to_chars(k,4,c[0],false);
    c[4] := 'k';
  end;

type string80 = string[80];

function string_to_chars (var str : string80; var s) : integer;
  begin string_to_chars := length(str);
    move(str[1],s,length(str));
  end;

const volume_id : fcb_name = '...........';

function vol_to_chars (var s) : integer;
  begin vol_to_chars := sizeof(volume_id);
    move(volume_id,s,sizeof(volume_id));
  end;

var form : string[80];

{
  Write out file information in the format specified by a template.
  The recognized macro characters are listed in the constants.
}


procedure write_file_info (var f : find_buf; var branch : string80);
  const
    macro_prefix = '$';
    c_time       = 'T';
    c_date       = 'D';
    c_path       = 'P';
    c_gt         = 'G';
    c_less       = 'L';
    c_bar        = 'B';
    c_file       = 'F';
    c_attr       = 'A';
    c_size_l     = '0';
    c_size_h     = '1';
    c_kbytes     = 'K';
    c_volume     = 'V';
  var
    i, j, n : integer;
    outs : string[80];
  begin
    i := 1; j := 1;
    while (i <= length(form)) and (j < 80) do
      begin
        if form[i] = macro_prefix then
          begin
            i := succ(i);
            case upcase(form[i]) of
              macro_prefix : begin outs[j] := macro_prefix; j := j+1; end;
              c_time    : j := j + time_to_chars(f.info.time,outs[j]);
              c_date    : j := j + date_to_chars(f.info.date,outs[j]);
              c_path    : j := j + string_to_chars(branch,outs[j]);
              c_gt      : begin outs[j] := '>'; j := j+1; end;
              c_less    : begin outs[j] := '<'; j := j+1; end;
              c_bar     : begin outs[j] := '|'; j := j+1; end;
              c_file    : j := j + asciiz_to_chars(f.info.pname[1],13,outs[j]);
              c_attr    : j := j + attr_to_chars(f.info.attr,outs[j]);
              c_size_l  : j := j + hex_to_chars(f.info.size_l,4,outs[j]);
              c_size_h  : j := j + hex_to_chars(f.info.size_h,4,outs[j]);
              c_kbytes  : j := j + kbytes_to_chars(f,outs[j]);
              c_volume  : j := j + vol_to_chars(outs[j]);
            end;
          end
        else
          begin outs[j] := form[i]; j := succ(j); end;
        i := succ(i);
      end;
    outs[0] := chr(j - 1);
    write(outs);
  end;


function min (a, b : integer) : integer;
  begin if a < b then min := a else min := b end;


procedure find2 (var branch, leaf : string80; attr, levels : integer);
  var f : find_buf; path : string80; error, i : integer; dir : string[14];
  begin
    if levels >= 1 then
      begin
        path := concat(branch,leaf);
        path[length(path) + 1] := #0;

        { list all files on this level }
        error := find_first(f,path[1],attr);
        while error = no_error do
          begin
            write_file_info(f,branch); writeln;
            error := find_next(f);
          end;

        if levels >= 2 then
          begin
            path := concat(branch,'*.*');
            path[length(path) + 1] := #0;

            { list all subdirectories to given level }
            error := find_first(f,path[1],$FF);
            while error = no_error do
              begin
                if (attribute_directory and f.info.attr) <> 0 then
                  begin
                    dir[0] := chr(scan_until(f.info.pname,#0,13));
                    move(f.info.pname,dir[1],length(dir));
                    if (dir <> '.') and (dir <> '..') then
                      begin
                        path := concat(branch,dir);
                        path[0] := succ(path[0]);
                        path[length(path)] := '\';
                        path[length(path) + 1] := #0;

                        find2(path,leaf,attr,levels - 1);
                      end;
                  end;
                error := find_next(f);
              end;
          end;
      end;
  end;

procedure do_find (var name : string80; attr, levels : integer);
  var branch, leaf : string80; i : integer;
  begin
    branch := name;
    i := min(scan_back_until(name[length(branch)],'\',length(branch)),
             scan_back_until(name[length(branch)],'/',length(branch)));
    leaf[0] := chr(i);
    move(branch[1 + length(branch) - i],leaf[1],length(leaf));
    branch[0] := chr(length(branch) - i);
    find2(branch,leaf,attr,levels);
  end;

var switch_char : char;

function get_switch_char : char;
  var reg : registers;
  begin
    reg.ah := $37;
    reg.al := 0;
    msdos(reg);
    get_switch_char := chr(reg.dl);
  end;

const
  default_fn   = '*.*';
  default_attr = $FF;
  default_form = '$f $d $t $a $k $v $p';

procedure process_command (var line : string80);
  var fn, temp : string80; n, i, levels, attribute, fn_drive : integer;
  begin
    fn[0] := #0; form[0] := #0;
    levels := 1; attribute := default_attr;
    i := 1;
    while (i < length(line)) do
      begin
        i := i + pop_token(line[i],temp[1],1 + length(line) - i,n);
        temp[0] := chr(n);
        if (temp[1] = switch_char) then
          begin
            case upcase(temp[2]) of
              'F' : attribute := attribute_read_only or attribute_hidden
                                 or attribute_system;
              'D' : attribute := attribute_directory;
              'S' : levels := 100;
              'X' :
                begin
                  i := i + scan_while(line[i],' ',1 + length(line) - i);
                  form[0] := chr(1 + length(line) - i);
                  move(line[i],form[1],length(form));
                  i := length(line) + 1;
                end;
            end
          end
        else if length(temp) > 0 then
          fn := temp;
      end;

    { check file name }
    if length(fn) = 0 then fn := default_fn;
    fn[length(fn) + 1] := #0;
    upcase_chars(fn[1],length(fn));
    for i := 1 to length(fn) do if fn[i] = '/' then fn[i] := '\';

    if fn[2] = ':' then
      fn_drive := ord(upcase(fn[1])) - ord('@')
    else
      fn_drive := 0;
    if not get_volume_id(fn_drive,volume_id) then
      fillchar(volume_id,sizeof(volume_id),' ');

    if length(form) = 0 then form := default_form;
    form[length(form) + 1] := #0;

    { call actual find routine }
    do_find(fn,attribute,levels);
  end;

var command_line : string80 absolute cseg:$80;

begin
  switch_char := get_switch_char;
  process_command(command_line);
end.